home *** CD-ROM | disk | FTP | other *** search
/ Eagles Nest BBS 8 / Eagles_Nest_Mac_Collection_Disc_8.TOAST / Developer Tools⁄Additions / MacScheme20 / Mathlib / vector.scm < prev   
Encoding:
Text File  |  1989-04-27  |  2.2 KB  |  83 lines  |  [TEXT/????]
  1. ;;; $Header: vector.scm,v 1.2 87/08/28 02:13:41 GMT gjs Exp $
  2. ;;;; Vector Package
  3.  
  4. (if-mit
  5.  (declare (usual-integrations = + - * /
  6.                  zero? 1+ -1+
  7.                  ;; truncate round floor ceiling
  8.                  sqrt exp log sin cos)))
  9.  
  10. ;;; This file uses the identification of the Scheme VECTOR data
  11. ;;; type with mathematical n-dimensional vectors.
  12. ;;; Thus we inherit the constructors VECTOR and MAKE-VECTOR,
  13. ;;; the selector VECTOR-REF and the mutator VECTOR-SET!, and 
  14. ;;; zero-based indexing 
  15.  
  16. (define (generate-vector size proc)
  17.   (let ((ans (make-vector size)))
  18.     (let loop ((i 0))
  19.       (if (= i size)
  20.       ans
  21.       (begin (vector-set! ans i (proc i))
  22.          (loop (+ i 1)))))))
  23.  
  24. (define ((vector-elementwise f) . vectors)
  25.   (generate-vector
  26.     (vector-length (car vectors))
  27.     (lambda (i)
  28.       (apply f (map (lambda (v) (vector-ref  v i))
  29.                     vectors)))))
  30.  
  31. (define add-vectors (vector-elementwise +))
  32.  
  33. (define sub-vectors (vector-elementwise -))
  34.  
  35. (define (scale-vector s)
  36.   (lambda (v)
  37.     (generate-vector (vector-length v)
  38.              (lambda (i) (* s (vector-ref v i))))))
  39.  
  40. (define (scalar*vector s v)
  41.   (generate-vector (vector-length v)
  42.                    (lambda (i) (* s (vector-ref v i)))))
  43.  
  44. (define (maxnorm v)
  45.   (apply max (map abs (vector->list v))))
  46.  
  47. (define (vector-accumulate acc fun init v)
  48.   (let ((l (vector-length v)))
  49.     (let loop ((i 0) (ans init))
  50.      (if (= i l)
  51.          ans
  52.          (loop (1+ i)
  53.            (acc (fun (vector-ref v i)) ans))))))
  54.  
  55. (define (general-inner-product addition multiplication)
  56.   (lambda (v1 v2)
  57.     (let ((n (vector-length v1)))
  58.       (if (not (= n (vector-length v2)))
  59.       (error "Unequal dimensions -- INNER-PRODUCT" v1 v2))
  60.       (let loop ((i 0) (ans 0))
  61.     (if (= i n)
  62.         ans
  63.         (loop (+ i 1)
  64.           (addition (multiplication (vector-ref v1 i)
  65.                                             (vector-ref v2 i))
  66.                 ans)))))))
  67.  
  68. (define dot-product
  69.   (general-inner-product + *))
  70.  
  71. (define inner-product
  72.   (general-inner-product +
  73.                         (lambda (z1 z2)
  74.                            (* (conjugate z1) z2))))
  75.  
  76. (define (euclidean-norm v)
  77.   (sqrt (inner-product v v)))
  78.  
  79. (define (unit-vector n i) ; #(0 0 ... 1 ... 0) n long, 1 in ith position
  80.   (let ((v (make-vector n 0)))
  81.     (vector-set! v i 1)
  82.     v))
  83.